home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / ciarnv85.arc / FSCRENZ.4TH < prev    next >
Text File  |  1986-04-08  |  5KB  |  113 lines
  1.       ( FSCRENZ.4TH      This file is canned in FORTH. )
  2.  
  3.         ( FILE MANAGEMENT USING DOS FUNCTION CALLS )                    
  4.  
  5. ( This program contains routines to do basic file manipulations:   )
  6. ( read, write, get a char, put a char, open and close files. )
  7. ( It also contains routines to implement the FORTH word ==> which  )
  8. ( loads the FORTH source file whose name is specified after the    )
  9. ( ==> and compiles or executes. E. G. ==> b:xeterm.4th would cause )
  10. ( the file xeterm.4th on the b drive to be loaded. )
  11.  
  12. ( The following assembler definitions add 2 words, INT21 and INT3. )
  13. ( They simply do interrupt 21 hex and interrupt 3 respectively. )
  14. ( Interrupt 21h is a DOS function call. It's number is passed in AH. )
  15. ASSEMBLER DEFINITIONS HEX CD 21 10MI INT21                      
  16.                       HEX CC 1MI INT3 FORTH DEFINITIONS         
  17.     
  18. ( The following word allows you to type DEBUG and enter the debugger )
  19. ( if you entered FORTH under DEBUG.COM )
  20. CODE  DEBUG INT3  NEXT JMP END-CODE                             
  21.     
  22. HEX 
  23.  
  24. 1A CONSTANT EOF 
  25. VARIABLE IOBUFF 
  26. VARIABLE IOERR   ( The error codes are stored in this variable. )
  27.  
  28. ( The routine DCALL is used to intiate DOS function calls in FORTH. )
  29. ( It leaves any error code returned or 0 and a flag indicating whether )
  30. ( the call was a success. )  
  31. CODE       DCALL                  
  32. AX         POP                    
  33. CX         POP                    
  34. DX         POP                    
  35. BX         POP                    
  36.            INT21                  
  37. AX         PUSH                   
  38. AX, # 0    MOV                    
  39. HERE 3 +   JB                     
  40. AX         INC                    
  41. AX         PUSH                   
  42. NEXT       JMP END-CODE           
  43.  
  44.  ( fh means file handle. fname means a pointer to the file name. )
  45.  ( pmode 
  46. : FREAD  ( fh,bufadr,#bytes -- #bytes )
  47.     3F00 DCALL IF 0 ELSE 0 SWAP THEN IOERR ! ;              
  48.  
  49. : FCREAT ( FNAME, PMODE -- FH ) 
  50.    ( RETURNS A ZERO IF IT FAILS, IOERR HAS ERR # )
  51.    0 ROT ROT 3C00 DCALL 
  52.    IF 0 ELSE 0 SWAP THEN IOERR ! ; 
  53. : FOPEN ( fname, rwmode -- fh )
  54.    SWAP OVER DUP 3D00 + DCALL
  55.    IF 0 ELSE 0 SWAP THEN IOERR ! ;  
  56. : FCLOSE ( fh -- )
  57.    0 0 3E00 DCALL IF DROP 0 THEN IOERR ! ;                
  58. : FWRITE ( fh, bufadr, #bytes -- #bytes )
  59.    4000 DCALL IF 0 ELSE 0 SWAP THEN IOERR ! ;             
  60. : FGETC  ( fh -- char or EOF )
  61.    IOBUFF 1 FREAD IF IOBUFF C@ ELSE EOF THEN ;             
  62. : FPUTC  (fh, char -- )
  63.    IOBUFF C! IOBUFF 1 FWRITE DROP ;                        
  64. VARIABLE FNAME 20 ALLOT           
  65. : FNAME? CR ." PLEASE ENTER NAME  " FNAME 10 EXPECT ;           
  66. : ZWORD BL WORD DUP DUP C@ + OVER DUP 1+ SWAP DUP C@ CMOVE      
  67.  0 SWAP C! ;                      
  68. : FTYPE ZWORD 0 FOPEN DUP IF      
  69.   PAGE BEGIN DUP FGETC DUP EMIT EOF = UNTIL ELSE                
  70.   ." FILE CANNOT BE OPENED " CR THEN ;                          
  71.  
  72.     
  73. HEX ( ROUTINES TO IMPLIMENT ==> FILE LOAD OPERATION )    
  74. VARIABLE ==>FN 40 ALLOT ( CURRENT FILE NAME )                   
  75. VARIABLE ==>FH 0 ==>FH ! ( OPEN FILE HANDLE OR 0 )              
  76. VARIABLE ==>FB 110 ALLOT ( FILE INPUT BUFFER )                  
  77. VARIABLE ==>L# ( LINE NUMBER IN CURRENT FILE )                  
  78.     
  79. : ==>EXP ( VECTOR EXPECT TO HERE )
  80.    ==>FH @ IF OVER + SWAP DO      
  81.          ==>FH @ FGETC DUP EOF = IF                             
  82.            DROP ==>FH @ FCLOSE 0 ==>FH ! ." OK" QUIT THEN            
  83.         DUP 0D = IF DROP BL THEN  
  84.         DUP 0A = IF               
  85.            LEAVE 1 ==>L# +! DROP BL THEN                        
  86.         I C! 0 I 1+ !             
  87.       1 /LOOP ELSE                
  88.      <EXPECT> THEN ;           
  89.     
  90. : QLFBRK ( PATCHES INTO QUIT'S LEFT BRACKET )                   
  91.    ==>FH @ IF ==>FH @ FCLOSE 0 ==>FH ! THEN [COMPILE] [ ;       
  92. : ?IOERR IOERR @ IF CR ." IOERR #" . CR ABORT THEN ;            
  93. : ZTYPE BEGIN DUP C@ ?DUP WHILE EMIT 1+ REPEAT DROP ;           
  94. : WHERE@ ( TO PATCH WHERE )       
  95.  @ DUP IF ELSE ==>FH @ IF         
  96.  CR ." LOADING FILE " ==>FN ZTYPE ."  LINE #" ==>L# ?           
  97.  CR CR TIB @ ZTYPE  THEN THEN ;   
  98.  
  99. : ==>INIT ' QLFBRK CFA 1E29 !     
  100.           ' WHERE@ CFA 2307 !     
  101.           ' ==>EXP CFA 'EXPECT !  
  102.           100 1E0E ! ( QUERY'S LENGTH )                         
  103.           ==>FB 100 0 FILL        
  104.           ==>FB TIB ! ;           
  105.     
  106. : ==> ZWORD TIB @ ==>FB - IF ==>INIT THEN                       
  107.       ==>FN 30 CMOVE ==>FN 0 FOPEN DUP IF                       
  108.       ==>FH ! 0 ==>L# ! BEGIN     
  109.          RP! QUERY INTERPRET AGAIN ELSE                         
  110.       ."   CANNOT OPEN FILE " ABORT THEN ;                      
  111.     
  112.     
  113.